home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / DOS2.4TH < prev    next >
Text File  |  1994-10-30  |  5KB  |  113 lines
  1. \ DOSINT FILE INTERFACE
  2. \ Code Copyright (C) 1986 by Thomas Almy.  All rights reserved.
  3. \ Permission is granted to registered users of ForthCMP to sell or distribute
  4. \ computer programs incorporating the compiled contents of this file.
  5.  
  6.  
  7. \ This file is intended to behave like UR/FORTH's "DOSINT"
  8. \ interface. There are some differences (such as "closed" in the level
  9. \ two functions being -1 so as not to interfere with standard input.
  10.  
  11. \ This file must be included after the application, just before
  12. \ "FORTHLIB".  the file "DOS1" should be included before the application.
  13.  
  14. \   Enjoy!
  15.  
  16. \   Tom
  17.  
  18.  
  19. 10 DECIMAL .( Loading DOS2) CR
  20.  
  21. \ Erzatz String Support 
  22. FIND STRBUF [IF] DROP ( good news ) [ELSE]  ( fake it )
  23. DSEG
  24. CREATE sB1 80 ALLOT CREATE sB2 80 ALLOT
  25. VARIABLE sBSW  sB1 sBSW !
  26. 1 1 IN/OUT
  27. : ASCIIZ  COUNT >R
  28.    sBSW @ sB1 sB2 XOR XOR DUP sBSW !
  29.    R@ CMOVE
  30.    R> sBSW @ + 0 C<-
  31.    sBSW @ ;      [THEN]
  32.  
  33. U: .FNAME  CELL+ COUNT TYPE ;
  34. U: HCB>N CELL+ ;
  35. U: HCB>H @ ;
  36. U: NAME>HCB DUP FCLOSE DROP CELL+ OVER C@ 1+ CMOVE ;
  37. U: FMAKE     OVER DUP  @ 0< 0= IF 2DROP DROP -1 EXIT THEN
  38.             CELL+ SWAP creat DUP -1 =  IF NIP EXIT THEN <- 0 ;
  39. U: FOPEN     OVER DUP  @ 0< 0= IF 2DROP DROP -1 EXIT THEN
  40.             CELL+ SWAP open DUP -1 =  IF NIP EXIT THEN <- 0 ;
  41. UNDEF open  CODE open  SI POP BX POP AX POP BX PUSH SI PUSH
  42.     CALL' ASCIIZ  SI POP AX DX MOV AX POP
  43.     61 # AH MOV  33 INT  ( ' seterr JMP ) END-CODE [THEN]
  44. L: seterr  <U ~ IF, 0 # errno [] MOV ELSE, AX errno [] MOV
  45.      -1 # AX MOV THEN, AX PUSH SI JMP END-CODE
  46. L: retstat  <U ~ IF, AX AX XOR AX errno [] MOV ELSE,
  47.      AX errno [] MOV -1 # AX MOV THEN, AX PUSH SI JMP END-CODE
  48. UNDEF creat CODE creat SI POP BX POP AX POP BX PUSH SI PUSH
  49.     CALL' ASCIIZ  SI POP AX DX MOV CX POP
  50.     60 # AH MOV 33 INT seterr JMP END-CODE [THEN]
  51. U: FSEEK  >R >R >R  @  R> R> R>  3 PICK 0< 0= IF lseek EXIT THEN 2DROP 2DROP -1. ;
  52. UNDEF lseek
  53. CODE lseek  SI POP  AX POP  CX POP  DX POP  BX POP
  54.    66 # AH MOV  33 INT  <U IF, AX errno [] MOV
  55.    -1 # AX MOV AX PUSH AX PUSH SI JMP THEN,
  56.   0 # errno [] MOV AX PUSH DX PUSH SI JMP END-CODE [THEN]
  57. U: FDEL  DUP @ 0< 0= IF DROP -1 EXIT THEN CELL+ unlink ;
  58. UNDEF unlink
  59. CODE unlink SI POP AX POP SI PUSH CALL' ASCIIZ SI POP
  60.     AX DX MOV  65 # AH MOV  33 INT retstat JMP END-CODE [THEN]
  61. U: FREAD ROT @ ?opn  IF -ROT ?DS: -ROT 63 r/w EXIT THEN
  62.              2DROP 0  ;
  63. U: FWRITE ROT @ ?opn  IF -ROT ?DS: -ROT 64 r/w EXIT THEN
  64.              2DROP 0  ;
  65. U: FREADL >R ROT @ ?opn IF -ROT R> 63 r/w EXIT THEN R> DROP 2DROP 0 ;
  66. U: FWRITEL >R ROT @ ?opn IF -ROT R> 64 r/w EXIT THEN R> DROP 2DROP 0 ;
  67. U: readl 63 r/w ;
  68. U: read ?DS: -ROT 63 r/w ;
  69. U: writel  64 r/w ;
  70. U: write ?DS: -ROT 64 r/w ;
  71. UNDEF r/w  CODE r/w ( handle seg buf len  command -- results.. )
  72.   SI POP AX POP  AL AH MOV  CX POP  DX POP  DI DS <SEG
  73.   DS POPSEG BX POP 33 INT DI DS >SEG
  74.   <U ~ IF, 0 # errno [] MOV ELSE, AX errno [] MOV
  75.      AX AX XOR THEN, AX PUSH SI JMP END-CODE    [THEN]
  76. U: FCLOSE    DUP @ ?opn IF close ELSE -1 THEN SWAP ON ;
  77. PRIMITIVE U: ?opn DUP 0< IF DROP 0 ELSE -1 THEN ;
  78. UNDEF close CODE close  SI POP  BX POP 62 # AH MOV
  79.    33 INT retstat JMP END-CODE [THEN]
  80. UNDEF chmod CODE chmod SI POP CX POP AX POP CX PUSH SI PUSH
  81.    CALL' ASCIIZ AX DX MOV SI POP CX POP -1 # CX CMP
  82.    =0 IF, HEX 4300 # AX MOV ELSE, 4301 # AX MOV THEN, DECIMAL
  83.    33 INT <U ~ IF, 0 # errno [] MOV CX PUSH SI JMP THEN,
  84.    AX errno [] MOV -1 # AX MOV AX PUSH SI JMP END-CODE [THEN]
  85. U: FREN  OVER @ OVER @ AND 0< IF 2DROP -1 EXIT THEN
  86.             CELL+ SWAP CELL+ SWAP rename ;
  87. UNDEF rename CODE rename SI POP AX POP SI PUSH CALL' ASCIIZ
  88.    SI POP AX BX MOV AX POP SI PUSH BX PUSH CALL' ASCIIZ
  89.    AX DX MOV DI POP SI POP DS PUSHSEG ES POPSEG
  90.    86 # AH MOV 33 INT retstat JMP  END-CODE [THEN]
  91. U: FCHDIR DUP @ 0< 0= IF DROP -1 EXIT THEN CELL+ chdir ;
  92. U: FMKDIR DUP @ 0< 0= IF DROP -1 EXIT THEN CELL+ mkdir ;
  93. U: FRMDIR DUP @ 0< 0= IF DROP -1 EXIT THEN CELL+ rmdir ;
  94. ?DEFINE chdir ?DEFINE mkdir ?DEFINE rmdir OR OR [IF]
  95. L: dircmd SI POP AX POP BX PUSH SI PUSH CALL' ASCIIZ
  96.  SI POP AX DX MOV AX POP 33 INT retstat JMP END-CODE [THEN]
  97. UNDEF chdir CODE chdir 59 # BH MOV dircmd JMP END-CODE [THEN]
  98. UNDEF mkdir CODE mkdir 57 # BH MOV dircmd JMP END-CODE [THEN]
  99. UNDEF rmdir CODE rmdir 58 # BH MOV dircmd JMP END-CODE [THEN]
  100. UNDEF getdir
  101.   1 0 IN/OUT CODE (getdir) AX SI MOV 0 # DL MOV 71 # AH MOV
  102.   33 INT RET END-CODE
  103. FIND STRBUF [IF] DROP
  104. : getdir 64 +STRBUF STRBUF (getdir) STRBUF -ASCIIZ ; [ELSE]
  105. : getdir sB1 1+ (getdir) sB1 1+ 64 0 SCAN DROP sB1 1+ -
  106.    sB1 C!  sB1 ; [THEN] [THEN]
  107. UNDEF firstf CODE firstf SI POP BX POP AX POP BX PUSH SI PUSH
  108.    CALL' ASCIIZ SI POP CX POP AX DX MOV 78 # AH MOV 33 INT
  109.    retstat JMP END-CODE [THEN]
  110. UNDEF nextf CODE nextf SI POP 79 # AH MOV 33 INT retstat JMP
  111.    END-CODE [THEN]
  112. 16 = [IF] HEX [THEN]
  113.